home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / VISUALBA / BOZOL2.ZIP / DATABASE.BAS < prev    next >
BASIC Source File  |  1994-02-08  |  23KB  |  747 lines
  1. '=========================================================================
  2. '         dBASE III Plus file interface subroutines begin here
  3. '=========================================================================
  4. SUB dBSetIndexTo(IX$,Fld$,e%)
  5. e%=0
  6. ' Make sure a database is open
  7. IF dBASEOpen%=0 THEN e%=1:EXIT SUB
  8.  
  9. ' close existing index if it is open
  10. IF IX$="" OR Index$<>"" THEN Index$="":_
  11.    CALL BT("","Q","","","","",r%)
  12. IF IX$="" THEN EXIT SUB
  13. ' verify filename exists
  14. IF DIR$(IX$)="" THEN e%=3:EXIT SUB
  15.  
  16. ' verify field exists in database
  17. Fld%=0:Fld$=UCASE$(Fld$)
  18.     FOR y%=1 TO NumberOfFields?
  19.             IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
  20.     NEXT y%
  21. IF Fld%=0 THEN e%=2:EXIT SUB
  22. Index$=IX$:IndexField$=Fld$:IndexField?=Fld%
  23. END SUB
  24.  
  25. SUB dBCreateIndex(IX$, Fld$, e%)
  26. REDIM K$(1000), D$(1000)
  27. Bt.Update.Always%=0
  28. ' Make sure a database is open
  29. IF dBASEOpen%=0 THEN e%=1:GOTO ExitSub
  30.  
  31. ' close existing index if it is open
  32. IF IX$="" OR Index$<>"" THEN Index$="":_
  33.    CALL BT("","Q","","","","",r%)
  34. IF IX$="" THEN EXIT SUB
  35.  
  36. ' verify field exists in database
  37. Fld%=0:Fld$=UCASE$(Fld$)
  38.     FOR y%=1 TO NumberOfFields?
  39.             IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
  40.     NEXT y%
  41. IF Fld%=0 THEN e%=2:GOTO EXITSUB
  42. Index$=IX$:IndexField$=Fld$:IndexField?=Fld%
  43.  
  44. ' Create the index and build it.
  45. K$=SPACE$(DBS(Fld%).FieldLength):D$=CHR$(0,0,0,0)
  46. CALL BT(Index$,"C",K$,D$,RK$,RD$,R%)
  47. IF NOT R% THEN E%=3:GOTO EXITSUB ' could not create index
  48. x%=CSRLIN:y%=POS(0)
  49. For y???=1 TO NumberOfRecords???
  50.     dBGetRecord Y???, e%
  51.         IF e% THEN e%=4:EXIT FOR
  52.     IF INSTAT OR COMCHARS% THEN A$=BOZOINKEY$:IF A$=CHR$(27) THEN e%=5:EXIT FOR
  53.  
  54.         ' ====================
  55.         ' remove the UCASE$ here if you do not want the index to be
  56.         ' create as case insensative.
  57.         K$=UCASE$(dBGetCField$(Indexfield$, e%))
  58.         '  ^^^^^^____________________________ ^
  59.  
  60.         IF e% THEN e%=6:EXIT FOR
  61.         D$=MKDWD$(Y???)  ' must know the record number!
  62.         INCR i%
  63.         K$(i%)=K$:D$(i%)=D$
  64.         IF i%=1000 THEN
  65.             FOR ii%=1 TO 1000
  66.         CALL BT(Index$,"A",K$(ii%),D$(ii%),RK$,RD$,r%)
  67.             IF NOT r% THEN e%=7:EXIT FOR
  68.                 NEXT ii%
  69.                 i%=0
  70.                 IF e%=7 THEN EXIT FOR
  71.     END IF
  72.         X%=BOZOCSRLIN:Y%=BOZOPOS:BOZOPRINT STR$(Y???):BOZOLOCATE X%,Y%
  73.         NEXT y???
  74.  
  75.             FOR ii%=1 TO i%
  76.         CALL BT(Index$,"A",K$(ii%),D$(ii%),RK$,RD$,r%)
  77.             IF NOT r% THEN e%=7:EXIT FOR
  78.                 NEXT ii%
  79.  
  80.     CALL BT(Index$,"Q","","","","",r%)
  81. ExitSub:
  82. BT.Update.Always%=-1
  83. END SUB
  84.  
  85. SUB dBSearchIndex(Findme$,e%)
  86. e%=0
  87. IF dBaseOpen%=0 THEN e%=1:EXIT SUB
  88. IF Index$="" THEN
  89.         BOZOPRINT CrLf$+"Index not open, scan database? (Y/N): "
  90.         YN$=BOZOINPUT$
  91.     IF UCASE$(YN$)="Y" THEN
  92.         ' scan the whole database for a match
  93.         FOR y???=1 TO NumberOfRecords???
  94.                 dBGetRecord y???, e%
  95.                     IF e% THEN EXIT FOR
  96.                     IF INSTR(FindMe$,RecordBlock$) THEN EXIT FOR
  97.         NEXT y???
  98.         IF y???=>NumberOfRecords THEN _
  99.                 BOZOPRINT "Not Found.  Press a key..."
  100.                 CWAIT
  101.                 BOZOPRINT CrLf$
  102.         END IF
  103. ELSE
  104.         Findme$=UCASE$(Findme$)
  105.     CALL BT(Index$,"S", Findme$, D$, RK$, RD$, r%)
  106.         'IF NOT r% THEN e%=2:EXIT SUB
  107.         FindMe$=RK$
  108.         R???=CVDWD(RD$)
  109.         IF R???>0 THEN CALL dBGetRecord(R???,e%)
  110. END IF
  111. END SUB
  112.  
  113. SUB dBSkip(NS%, e%)
  114. e%=0
  115. IF LEN(INDEX$) THEN
  116.         DO
  117.     IF NS%<0 THEN BT Index$,"P","","",K$,D$,r%:INCR NS% ELSE _
  118.                       BT Index$,"N","","",K$,D$,r%:DECR NS%
  119.         IF NOT r% THEN e%=-1:EXIT SUB
  120.         IF INSTAT THEN IF A$=CHR$(27) THEN NS%=0
  121.         LOOP WHILE NS%<>0
  122.         dBGetRecord CVDWD(D$), e%
  123. ELSE
  124.     RN???=RecNum??? + NS%
  125.         IF RN??? < 1 THEN RN???=1:e%=-1
  126.         IF RN??? > NumberOfRecords??? THEN RN???=NumberOfRecords???:e%=-1
  127.         dBGetRecord RN???,e%
  128. END IF
  129. END SUB
  130.  
  131. SUB dBGotoTop (e%)
  132. e%=0
  133. IF LEN(INDEX$) THEN
  134.     BT Index$,"F","","",K$,D$,r%
  135.         IF NOT r% THEN e%=-2:EXIT SUB
  136.         DBGetRecord CVDWD(D$),e%
  137. ELSE
  138.     DBGetRecord 1, e%
  139. END IF
  140. END SUB
  141.  
  142. SUB dBGotoBottom (e%)
  143. e%=0
  144. IF LEN(INDEX$) THEN
  145.     BT Index$,"L","","",K$,D$,r%
  146.         IF NOT r% THEN e%=-2:EXIT SUB
  147.         DBGetRecord CVDWD(D$),e%
  148. ELSE
  149.     DBGetRecord NumberOfRecords???, e%
  150. END IF
  151. END SUB
  152.  
  153. SUB dBEditRecord (RN???, e%)
  154. e%=0
  155.     dBGetRecord RN???, e%
  156.         IF e% THEN EXIT SUB
  157.  
  158. ' remove entry from index
  159. IF LEN(INDEX$) THEN
  160.     BT Index$,"D",UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
  161.     IF NOT r% THEN BOZOPRINT "Error accessing index file"+CrLf$
  162. END IF
  163.  
  164.         ' edit the record
  165.         DBEditFields e%
  166.  
  167. ' replace entry in index
  168. IF LEN(INDEX$) THEN
  169.     BT Index$,"A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
  170.     IF NOT r% THEN BOZOPRINT "Error updating index file"+CrLf$
  171. END IF
  172. END SUB
  173.  
  174. SUB dBAppendRecord (e%)
  175.     e%=0
  176.         IF dBaseOpen%=0 THEN e%=1:EXIT SUB
  177.     Recnum???=0
  178.         RecordBlock$=SPACE$(LEN(RecordBlock$))
  179.     DbEditFields e%
  180.     IF Recnum???>0 AND LEN(INDEX$) THEN
  181.             BT Index$, "A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RecNum???),"","",r%
  182.                 IF NOT r% THEN BOZOPRINT "Error appending index file."+CrLf$
  183.         END IF
  184. END SUB
  185.  
  186. SUB dBDefaultFormat
  187. ' Create a default field edit format.
  188. IF dBaseOpen%=0 THEN EXIT SUB
  189. REDIM DBE(256) AS DBaseEditFormat
  190. k%=1
  191. FOR y%=1 to NumberOfFields?
  192.         INCR j%:IF j%=20 THEN j%=1:k%=k%+40:IF K%=81 THEN EXIT FOR
  193.     DBE(y%).FieldName = DBS(y%).FieldName
  194.         DBE(y%).FieldType = DBS(y%).FieldType
  195.         DBE(y%).FieldLength = DBS(y%).FieldLength
  196.         DBE(y%).FieldRow = j%
  197.         DBE(y%).FieldCol = k%+(11-LEN(RTRIM$(DBS(y%).FieldName,CHR$(0))))
  198.     DBE(y%).FieldFG = 0
  199.         DBE(y%).FieldBG = 7
  200. NEXT y%
  201. END SUB
  202.  
  203. SUB dBCreateFormat
  204. IF dBaseOpen%=0 THEN BOZOPRINT "No Database is in USE."+CrLf$:EXIT SUB
  205. DO
  206. BOZOCLS
  207. DBView
  208. BOZOLOCATE 23,1:BOZOCOLOR 7,0:BOZOPRINT "Press ENTER to Accept or Fieldname to change: "
  209. F$=BOZOINPUT$
  210. IF F$="" THEN
  211.     B%=FREEFILE
  212.         BOZOLOCATE 23,1:BOZOPRINT SPACE$(80)
  213.         BOZOLOCATE 23,1:BOZOPRINT "Enter format filename: "
  214.         F$=BOZOINPUT$
  215.         IF F$="" THEN F$="NONAME.FMT"
  216.         OPEN F$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
  217.         Fld%=1
  218.         DO UNTIL DBE(Fld%).FieldLength=0
  219.             PUT #B%, Fld%, DBE(Fld%)
  220.                 INCR Fld%
  221.         LOOP
  222.         EXIT LOOP
  223. ELSE
  224. Fld%=0
  225. F$=UCASE$(F$)
  226.     FOR y%=1 TO NumberOfFields?
  227.             IF INSTR(DBS(y%).FieldName,F$)=1 THEN Fld%=y%:EXIT FOR
  228.     NEXT y%
  229. IF Fld%=0 THEN BOZOLOCATE 23,1:BOZOPRINT SPACE$(80):BOZOLOCATE 23,1:BOZOPRINT "BAD FIELD NAME":SOUND 50,4:DELAY 2:ITERATE LOOP
  230. BOZOLOCATE 23,1:BOZOPRINT SPACE$(80):BOZOLOCATE 23,1:BOZOPRINT "Use arrow keys to place new field position"
  231. X%=DBE(Fld%).FieldRow
  232. Y%=DBE(Fld%).FieldCol
  233. F$=RTRIM$(DBE(Fld%).FieldName,CHR$(0))+":"+STRING$(DBE(Fld%).FieldLength,176)
  234. ' edit field location
  235. DBSCRNFIND X%, Y%, F$
  236. IF X%=0 THEN EXIT LOOP
  237. DBE(Fld%).FieldRow = X%
  238. DBE(Fld%).FieldCol = Y%
  239. END IF
  240. LOOP
  241. END SUB
  242.  
  243. SUB dBSetFormatTo(FormatFileName$,Ecode%)
  244. Ecode%=0
  245. IF FormatFileName$="" THEN ERASE DBE():EXIT SUB
  246. IF Dir$(FormatFileName$)="" THEN Ecode%=1:EXIT SUB
  247. B%=FREEFILE
  248. OPEN FormatFileName$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
  249. FOR y%=1 TO LOF(B%)\LEN(DBE)
  250.     GET #B%, y%, DBE(y%)
  251. NEXT y%
  252. CLOSE #B%
  253. END SUB
  254.  
  255. SUB dBView
  256. Fld%=1
  257. of%=(PBVScrnTxtAttr AND &HF) ' get the original foreground and background
  258. ob%=(PBVScrnTxtAttr \ &H10)  ' BOZOCOLORs, in case they change.
  259. DO UNTIL DBE(Fld%).FieldLength=0
  260.     BOZOLOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol
  261.         BOZOCOLOR of%,ob%
  262.         BOZOPRINT RTRIM$(DBE(Fld%).FieldName,chr$(0))+":"
  263.         X%=BOZOCSRLIN:Y%=BOZOPOS
  264.         BOZOCOLOR DBE(Fld%).FieldFG,DBE(Fld%).FieldBG
  265.         BOZOPRINT SPACE$(DBE(Fld%).FieldLength)
  266.     BOZOLOCATE X%,Y%
  267.         IF DBE(Fld%).FieldType="N" THEN
  268.             BOZOPRINT LTRIM$(STR$(dBGetNField!((DBE(Fld%).FieldName),E%)))
  269.                 IF E% THEN BOZOPRINT "???"
  270.     ELSE
  271.             BOZOPRINT dBGetCField$((DBE(Fld%).FieldName),E%)
  272.